home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 4: GNU Archives / Linux Cubed Series 4 - GNU Archives.iso / gnu / binutils.7 / binutils / binutils-2.7 / gas / testsuite / lib / gas-defs.exp < prev    next >
Encoding:
Text File  |  1996-07-04  |  12.3 KB  |  486 lines
  1. # Copyright (C) 1993, 1994 Free Software Foundation, Inc.
  2.  
  3. # This program is free software; you can redistribute it and/or modify
  4. # it under the terms of the GNU General Public License as published by
  5. # the Free Software Foundation; either version 2 of the License, or
  6. # (at your option) any later version.
  7. # 
  8. # This program is distributed in the hope that it will be useful,
  9. # but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11. # GNU General Public License for more details.
  12. # 
  13. # You should have received a copy of the GNU General Public License
  14. # along with this program; if not, write to the Free Software
  15. # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  */
  16.  
  17. # Please email any bugs, comments, and/or additions to this file to:
  18. # DejaGnu@cygnus.com
  19.  
  20. # This file was written by Ken Raeburn (raeburn@cygnus.com).
  21.  
  22. proc gas_version {} {
  23.     global AS
  24.     catch "exec $AS -version < /dev/null" tmp
  25.     # Should find a way to discard constant parts, keep whatever's
  26.     # left, so the version string could be almost anything at all...
  27.     regexp "version (cygnus-|)\[-0-9.a-zA-Z-\]+" $tmp version
  28.     set tmp $version
  29.     clone_output "[which $AS] $version\n"
  30.     unset tmp
  31.     unset version
  32. }
  33.  
  34. proc gas_run { prog as_opts redir } {
  35.     global AS
  36.     global ASFLAGS
  37.     global comp_output
  38.     global srcdir
  39.     global subdir
  40.     global host_triplet
  41.  
  42.     verbose "Executing $AS $ASFLAGS $as_opts $prog $redir"
  43.     catch "exec $srcdir/lib/run $AS $ASFLAGS $as_opts $srcdir/$subdir/$prog $redir" comp_output
  44.     set comp_output [prune_system_crud $host_triplet $comp_output]
  45. }
  46.  
  47. proc all_ones { args } {
  48.     foreach x $args { if [expr $x!=1] { return 0 } }
  49.     return 1
  50. }
  51.  
  52. proc gas_start { prog as_opts } {
  53.     global AS
  54.     global ASFLAGS
  55.     global srcdir
  56.     global subdir
  57.     global spawn_id
  58.  
  59.     verbose "Starting $AS $ASFLAGS $as_opts $prog" 2
  60.     catch {
  61.     spawn -noecho -nottycopy $srcdir/lib/run $AS $ASFLAGS $as_opts $srcdir/$subdir/$prog
  62.     } foo
  63.     if ![regexp {^[0-9]+} $foo] then {
  64.     perror "Can't run $subdir/$prog: $foo"
  65.     }
  66. }
  67.  
  68. proc gas_finish { } {
  69.     global spawn_id
  70.  
  71.     catch "close"
  72.     catch "wait"
  73. }
  74.  
  75. proc want_no_output { testname } {
  76.     global comp_output
  77.  
  78.     if ![string match "" $comp_output] then {
  79.     send_log "$comp_output\n"
  80.     verbose "$comp_output" 3
  81.     }
  82.     if [string match "" $comp_output] then {
  83.     pass "$testname"
  84.     return 1
  85.     } else {
  86.     fail "$testname"
  87.     return 0
  88.     }
  89. }
  90.  
  91. proc gas_test_old { file as_opts testname } {
  92.     gas_run $file $as_opts ""
  93.     return [want_no_output $testname]
  94. }
  95.  
  96. proc gas_test { file as_opts var_opts testname } {
  97.     global comp_output
  98.  
  99.     set i 0
  100.     foreach word $var_opts {
  101.     set ignore_stdout($i) [string match "*>" $word]
  102.     set opt($i) [string trim $word {>}]
  103.     incr i
  104.     }
  105.     set max [expr 1<<$i]
  106.     for {set i 0} {[expr $i<$max]} {incr i} {
  107.     set maybe_ignore_stdout ""
  108.     set extra_opts ""
  109.     for {set bit 0} {(1<<$bit)<$max} {incr bit} {
  110.         set num [expr 1<<$bit]
  111.         if [expr $i&$num] then {
  112.         set extra_opts "$extra_opts $opt($bit)"
  113.         if $ignore_stdout($bit) then {
  114.             set maybe_ignore_stdout ">/dev/null"
  115.         }
  116.         }
  117.     }
  118.     set extra_opts [string trim $extra_opts]
  119.     gas_run $file "$as_opts $extra_opts" $maybe_ignore_stdout
  120.  
  121.     # Should I be able to use a conditional expression here?
  122.     if [string match "" $extra_opts] then {
  123.         want_no_output $testname
  124.     } else {
  125.         want_no_output "$testname ($extra_opts)"
  126.     }
  127.     }
  128.     if [info exists errorInfo] then {
  129.         unset errorInfo
  130.     }
  131. }
  132.  
  133. proc gas_test_ignore_stdout { file as_opts testname } {
  134.     global comp_output
  135.  
  136.     gas_run $file $as_opts ">/dev/null"
  137.     want_no_output $testname
  138. }
  139.  
  140. proc gas_test_error { file as_opts testname } {
  141.     global comp_output
  142.  
  143.     gas_run $file $as_opts ">/dev/null"
  144.     if ![string match "" $comp_output] then {
  145.     send_log "$comp_output\n"
  146.     verbose "$comp_output" 3
  147.     }
  148.     if [string match "" $comp_output] then {
  149.     fail "$testname"
  150.     } else {
  151.     pass "$testname"
  152.     }
  153. }
  154.  
  155. proc gas_exit {} {}
  156.  
  157. proc gas_init {} {
  158.     global target_cpu
  159.     global target_cpu_family
  160.     global target_family
  161.     global target_vendor
  162.     global target_os
  163.     global stdoptlist
  164.  
  165.     case "$target_cpu" in {
  166.     "m68???"        { set target_cpu_family m68k }
  167.     "i[34]86"        { set target_cpu_family i386 }
  168.     default            { set target_cpu_family $target_cpu }
  169.     }
  170.  
  171.     set target_family "$target_cpu_family-$target_vendor-$target_os"
  172.     set stdoptlist "-a>"
  173.     # Need to return an empty string.
  174.     return
  175. }
  176.  
  177. # This proc requires two input files -- the .s file containing the
  178. # assembly source, and a .d file containing the expected output from
  179. # objdump or nm or whatever, and leading comments indicating any options
  180. # to be passed to the assembler or dump program.
  181.  
  182. proc run_dump_test { name } {
  183.     global subdir srcdir
  184.     global OBJDUMP NM AS OBJCOPY
  185.     global OBJDUMPFLAGS NMFLAGS ASFLAGS OBJCOPYFLAGS
  186.     global host_triplet
  187.  
  188.     if [string match "*/*" $name] {
  189.     set file $name
  190.     set name [file tail $name]
  191.     } else {
  192.     set file "$srcdir/$subdir/$name"
  193.     }
  194.     set opt_array [slurp_options "${file}.d"]
  195.     if { $opt_array == -1 } {
  196.     unresolved $subdir/$name
  197.     return
  198.     }
  199.     set opts(as) {}
  200.     set opts(objdump) {}
  201.     set opts(nm) {}
  202.     set opts(objcopy) {}
  203.     set opts(name) {}
  204.     set opts(PROG) {}
  205.     set opts(source) {}
  206.  
  207.     foreach i $opt_array {
  208.     set opt_name [lindex $i 0]
  209.     set opt_val [lindex $i 1]
  210.     if ![info exists opts($opt_name)] {
  211.         perror "unknown option $opt_name in file $file.d"
  212.         unresolved $subdir/$name
  213.         return
  214.     }
  215.     if [string length $opts($opt_name)] {
  216.         perror "option $opt_name multiply set in $file.d"
  217.         unresolved $subdir/$name
  218.         return
  219.     }
  220.     set opts($opt_name) $opt_val
  221.     }
  222.  
  223.     if {$opts(PROG) != ""} {
  224.     switch -- $opts(PROG) {
  225.         objdump
  226.         { set program objdump }
  227.         nm
  228.         { set program nm }
  229.         objcopy
  230.         { set program objcopy }
  231.         default
  232.         { perror "unrecognized program option $opts(PROG) in $file.d"
  233.           unresolved $subdir/$name
  234.           return }
  235.     }
  236.     } elseif {$opts(objdump) == "" && $opts(nm) != ""} {
  237.     set program nm
  238.     } elseif {$opts(objdump) != "" && $opts(nm) == ""} {
  239.     set program objdump
  240.     } elseif {$opts(objcopy) != ""} {
  241.     set program objcopy
  242.     } else {
  243.     perror "dump program unspecified in $file.d"
  244.     unresolved $subdir/$name
  245.     return
  246.     }
  247.     set progopts1 $opts($program)
  248.     eval set progopts \$[string toupper $program]FLAGS
  249.     eval set binary \$[string toupper $program]
  250.     if { $opts(name) == "" } {
  251.     set testname "$subdir/$name"
  252.     } else {
  253.     set testname $opts(name)
  254.     }
  255.  
  256.     if { $opts(source) == "" } {
  257.     set sourcefile ${file}.s
  258.     } else {
  259.     set sourcefile $srcdir/$subdir/$opts(source)
  260.     }
  261.  
  262.     send_log "$AS $ASFLAGS $opts(as) -o dump.o $sourcefile\n"
  263.     catch "exec $srcdir/lib/run $AS $ASFLAGS $opts(as) -o dump.o $sourcefile" comp_output
  264.     set comp_output [prune_system_crud $host_triplet $comp_output]
  265.  
  266.     if ![string match "" $comp_output] then {
  267.     send_log "$comp_output\n"
  268.     verbose "$comp_output" 3
  269.     fail $testname
  270.     return
  271.     }
  272.  
  273.     if { [which $binary] == 0 } {
  274.     untested $testname
  275.     return
  276.     }
  277.  
  278.     if { $progopts1 == "" } { set $progopts1 "-r" }
  279.     verbose "running $binary $progopts $progopts1" 3
  280.     if { $program == "objcopy" } {
  281.     send_log "$binary $progopts $progopts1 dump.o dump.out\n"
  282.     catch "exec $binary $progopts $progopts1 dump.o dump.out" comp_output
  283.     set comp_output [prune_system_crud $host_triplet $comp_output]
  284.     if ![string match "" $comp_output] then {
  285.         send_log "$comp_output\n"
  286.         fail $testname
  287.         return
  288.     }
  289.     } else {
  290.     send_log "$binary $progopts $progopts1 dump.o > dump.out\n"
  291.     catch "exec $binary $progopts $progopts1 dump.o > dump.out" comp_output
  292.     set comp_output [prune_system_crud $host_triplet $comp_output]
  293.     if ![string match "" $comp_output] then {
  294.         send_log "$comp_output\n"
  295.         fail $testname
  296.         return
  297.     }
  298.     }
  299.  
  300.     verbose_eval {[file_contents "dump.out"]} 3
  301.     if { [regexp_diff "dump.out" "${file}.d"] } then {
  302.     fail $testname
  303.     return
  304.     }
  305.  
  306.     pass $testname
  307. }
  308.  
  309. proc slurp_options { file } {
  310.     if [catch { set f [open $file r] } x] {
  311.     #perror "couldn't open `$file': $x"
  312.     perror "$x"
  313.     return -1
  314.     }
  315.     set opt_array {}
  316.     # whitespace expression
  317.     set ws  {[     ]*}
  318.     set nws {[^     ]*}
  319.     # whitespace is ignored anywhere except within the options list;
  320.     # option names are alphabetic only
  321.     set pat "^#${ws}(\[a-zA-Z\]*)$ws:${ws}(.*)$ws\$"
  322.     while { [gets $f line] != -1 } {
  323.     set line [string trim $line]
  324.     # Whitespace here is space-tab.
  325.     if [regexp $pat $line xxx opt_name opt_val] {
  326.         # match!
  327.         lappend opt_array [list $opt_name $opt_val]
  328.     } else {
  329.         break
  330.     }
  331.     }
  332.     close $f
  333.     return $opt_array
  334. }
  335.  
  336. proc objdump { opts } {
  337.     global OBJDUMP
  338.     global comp_output
  339.     global host_triplet
  340.  
  341.     catch "exec $OBJDUMP $opts" comp_output
  342.     set comp_output [prune_system_crud $host_triplet $comp_output]
  343.     verbose "objdump output=$comp_output\n" 3
  344. }
  345.  
  346. proc objdump_start_no_subdir { prog opts } {
  347.     global OBJDUMP
  348.     global srcdir
  349.     global spawn_id
  350.  
  351.     verbose "Starting $OBJDUMP $opts $prog" 2
  352.     catch {
  353.     spawn -noecho -nottyinit $srcdir/lib/run $OBJDUMP $opts $prog
  354.     } foo
  355.     if ![regexp {^[0-9]+} $foo] then {
  356.     perror "Can't run $prog: $foo"
  357.     }
  358. }
  359.  
  360. proc objdump_finish { } {
  361.     global spawn_id
  362.  
  363.     catch "close"
  364.     catch "wait"
  365. }
  366.  
  367. # Default timeout is 10 seconds, loses on a slow machine.  But some
  368. # configurations of dejagnu may override it.
  369. if {$timeout<120} then { set timeout 120 }
  370.  
  371. expect_after -i {
  372.     timeout            { perror "timeout" }
  373.     "virtual memory exhausted"    { perror "virtual memory exhausted" }
  374.     buffer_full            { perror "buffer full" }
  375.     eof                { perror "eof" }
  376. }
  377.  
  378. # regexp_diff, based on simple_diff taken from ld test suite
  379. #    compares two files line-by-line
  380. #    file1 contains strings, file2 contains regexps and #-comments
  381. #    blank lines are ignored in either file
  382. #    returns non-zero if differences exist
  383. #
  384. proc regexp_diff { file_1 file_2 } {
  385.  
  386.     set eof -1
  387.     set end 0
  388.     set differences 0
  389.     set diff_pass 0
  390.  
  391.     if [file exists $file_1] then {
  392.     set file_a [open $file_1 r]
  393.     } else {
  394.     warning "$file_1 doesn't exist"
  395.     return 1
  396.     }
  397.  
  398.     if [file exists $file_2] then {
  399.     set file_b [open $file_2 r]
  400.     } else {
  401.     fail "$file_2 doesn't exist"
  402.     close $file_a
  403.     return 1
  404.     }
  405.  
  406.     verbose " Regexp-diff'ing: $file_1 $file_2" 2
  407.  
  408.     while { $differences == 0 && $end == 0 } {
  409.     set line_a ""
  410.     set line_b ""
  411.     while { [string length $line_a] == 0 } {
  412.         if { [gets $file_a line_a] == $eof } {
  413.         set end 1
  414.         break
  415.         }
  416.     }
  417.     while { [string length $line_b] == 0 || [string match "#*" $line_b] } {
  418.         if [ string match "#pass" $line_b ] {
  419.         set end 1
  420.         set diff_pass 1
  421.         break
  422.         }
  423.         if { [gets $file_b line_b] == $eof } {
  424.         set end 1
  425.         break
  426.         }
  427.     }
  428.     if { $end } { break }
  429.     verbose "regexp \"^$line_b$\"\nline   \"$line_a\"" 3
  430.     if ![regexp "^$line_b$" "$line_a"] {
  431.         send_log "regexp_diff match failure\n"
  432.         send_log "regexp \"^$line_b$\"\nline   \"$line_a\"\n"
  433.         set differences 1
  434.     }
  435.     }
  436.  
  437.     if { $differences == 0 && !$diff_pass && [eof $file_a] != [eof $file_b] } {
  438.     send_log "different lengths\n"
  439.     verbose "different lengths" 3
  440.     set differences 1
  441.     }
  442.  
  443.     close $file_a
  444.     close $file_b
  445.  
  446.     return $differences
  447. }
  448.  
  449. proc file_contents { filename } {
  450.     set file [open $filename r]
  451.     set contents [read $file]
  452.     close $file
  453.     return $contents
  454. }
  455.  
  456. proc verbose_eval { expr { level 1 } } {
  457.     global verbose
  458.     if $verbose>$level then { eval verbose "$expr" $level }
  459. }
  460.  
  461. # This definition is taken from an unreleased version of DejaGnu.  Once
  462. # that version gets released, and has been out in the world for a few
  463. # months at least, it may be safe to delete this copy.
  464. if ![string length [info proc prune_system_crud]] {
  465.     #
  466.     # prune_system_crud -- delete various system verbosities from TEXT on SYSTEM
  467.     #
  468.     # An example is:
  469.     # ld.so: warning: /usr/lib/libc.so.1.8.1 has older revision than expected 9
  470.     #
  471.     # SYSTEM is typical $target_triplet or $host_triplet.
  472.     #
  473.     # This is useful when trying to do pattern matches on program output.
  474.     # Sites with particular verbose os's may wish to override this in site.exp.
  475.     #
  476.     proc prune_system_crud { system text } {
  477.     # This is from sun4's.  Do it for all machines for now.
  478.     # The "\\1" is to try to preserve a "\n" but only if necessary.
  479.     regsub -all "(^|\n)(ld.so: warning:\[^\n\]*\n?)+" $text "\\1" text
  480.  
  481.     # It might be tempting to get carried away and delete blank lines, etc.
  482.     # Just delete *exactly* what we're ask to, and that's it.
  483.     return $text
  484.     }
  485. }
  486.